; -*- Mode:LISP; Package:ZWEI; Base:8; Readtable:ZL -*-
;;; Operating system dependent mail file handling, extension of MFILES

; ** (c) Copyright 1982 Massachusetts Institute of Technology **
; An invalid Enhancements copyright notice on AI:ZMAIL; MFHOST 15 removed on 3/31/82 by RG
;  This file had been installed as the official MIT source in direct contravention
;  to instructions to Symbolics personnel acting on MIT's behalf.

(DEFVAR *ZMAIL-HOMEDIR-REAL-NEW-MAIL-FILENAME* NIL
  "If non-NIL, pretend this is where we always should get new mail for FS:USER-ID.")

(DEFVAR *REAL-MAIL-FILE-HOST-ALIST* NIL "An alist of hosts and a real file name to override what file to get new mail for ourselves.")

(DEFUN MAYBE-OVERRIDDEN-MAIL-PATHNAME (PATHNAME &OPTIONAL (USER USER-ID) &AUX VALUE)
  "Return the pathname of the mail file if it is overridden by PATHNAME, else NIL."
  (UNLESS (NOT (STRING-EQUAL FS::USER-ID USER)) ;;if its for someone else, its not overridden
    (OR (AND (EQ (FS::USER-HOMEDIR) PATHNAME)  ;;override it with this variable
             *ZMAIL-HOMEDIR-REAL-NEW-MAIL-FILENAME*)
        (LET ((HOST (SEND PATHNAME :HOST)))
          (DOLIST (ELEM *REAL-MAIL-FILE-HOST-ALIST*)
            (COND ((EQ HOST (SI:PARSE-HOST (CAR ELEM) T))
                   (SETQ VALUE (CDR ELEM)))))
          VALUE))))

(defun run-gmsgs-p (&optional maybe)
  (CASE *RUN-GMSGS-P*
    (:YES T)
    (:NO NIL)
    (:ONCE-ONLY maybe)
    (t *run-gmsgs-p*)))

;;; The :DO-MSGS method returns the file to find the messages in
(DEFMETHOD (SI:HOST :DO-GMSGS) (STREAM)
  (MULTIPLE-VALUE-BIND (FILE-NAME UNAME-STRING) (SEND SELF :GMSGS-PATHNAME)
    (WITH-OPEN-STREAM (CSTREAM (CHAOS:OPEN-STREAM SELF
                                                  (GMSGS-CONTACT-NAME
                                                    FILE-NAME UNAME-STRING)
                                                  :DIRECTION :INPUT))
      (STREAM-COPY-UNTIL-EOF CSTREAM STREAM))
    FILE-NAME))

(DEFUN GMSGS-CONTACT-NAME (INBOX USER-STRING)
  (STRING-APPEND "GMSGS " USER-STRING " "
                 (IF (EQ (SEND INBOX :SYSTEM-TYPE) :ITS) "//G" "")
                 *GMSGS-OTHER-SWITCHES* " ")) ; 20X lossage

;;; :GMSGS-PATHNAME should return two values: the expected GMSGS inbox for ZMAIL
;;; and a string which determines the user (or his GMSGS inbox in the case of ITS).
(DEFMETHOD (SI:HOST :GMSGS-PATHNAME) ()
  (VALUES (SEND (FS::USER-HOMEDIR SELF) :NEW-PATHNAME
                :NAME "GMSGS" :CANONICAL-TYPE :TEXT)
          (OR (FS::UNAME-ON-HOST SELF) USER-ID)))

;;; ITS mail files
(DEFFLAVOR ITS-MAIL-FILE-MIXIN () ()
  :ABSTRACT-FLAVOR
  (:REQUIRED-FLAVORS ZMAIL-DISK-BUFFER))

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :HEADER-COMPATIBLE-MAIL-FILE-FORMATS) ()
  '("Mail" "Rmail" "Babyl" "Tenex mail"))

(DEFFLAVOR ITS-INBOX-BUFFER () (ITS-MAIL-FILE-MIXIN INBOX-BUFFER))

(DEFMETHOD (ITS-INBOX-BUFFER :FORMAT-NAME) () "Mail")

;;should have a similar kludge for determining the inbox filename
(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM &AUX FLAVOR APPEND-P)
  (IF (NULL STREAM)
      (SETQ FLAVOR 'RMAIL-FILE-BUFFER)
      (LET ((FIRST-LINE (SEND STREAM :LINE-IN)))
        (SEND STREAM :SET-POINTER 0)
        (IF (STRING-EQUAL FIRST-LINE "Babyl Options:")
            ;; Looks like a babyl file
            (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER)
            ;; Default is rmail file
            (SETQ FLAVOR 'RMAIL-FILE-BUFFER)
            (AND (STRING-EQUAL FIRST-LINE "*APPEND*")
                 (SETQ APPEND-P T)))))
  (VALUES FLAVOR APPEND-P))

(DEFVAR *ZMAIL-FILE-FN2S* '("BABYL" "RMAIL"))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-NAMES) ()
  (LOOP FOR FN2 IN *ZMAIL-FILE-FN2S*
        COLLECT (SEND SELF :NEW-PATHNAME :NAME USER-ID :TYPE FN2 :VERSION :NEWEST)))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS) ()
  '(RMAIL-FILE-BUFFER BABYL-MAIL-FILE-BUFFER))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (OR (MAYBE-OVERRIDDEN-MAIL-PATHNAME SELF)
      (SEND SELF :NEW-PATHNAME :NAME (OR FS::NAME USER-ID)
                    :TYPE "MAIL")))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  (STRING-APPEND "_Z" (SEND SELF :TYPE)))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :INBOX-BUFFER-FLAVOR) ()
  'ITS-INBOX-BUFFER)

(DEFMETHOD (SI:HOST-ITS-MIXIN :GMSGS-PATHNAME) ()
  (LET* ((HOMEDIR (FS::USER-HOMEDIR SELF))
         (INBOX (SEND (SEND HOMEDIR :NEW-PATHNAME :TYPE "GMSGS")
                      :NEW-SUGGESTED-NAME (FS::UNAME-ON-HOST SELF))))
    (VALUES INBOX
            (FORMAT () "~A;~A" (SEND INBOX :DIRECTORY) (SEND INBOX :NAME)))))

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :MAIL-FILE-REPARSABLE-P) () T)

;;; Messages on ITS end with a line with a  in it
;;; The MSG-END-BP will be before the .
;;; The MSG-REAL-END-BP is the start of the following line.
(DEFMETHOD (ITS-MAIL-FILE-MIXIN :LINE-END-OF-MSG-P) (LINE LENGTH &REST IGNORE &AUX END-IDX)
  (AND (> LENGTH 0) (SETQ END-IDX (STRING-SEARCH-CHAR #\ LINE))
       (NOT (DO I (1+ END-IDX) (1+ I) ( I LENGTH)
                (OR (MEMQ (CHAR LINE I) '(#/SP #/TAB #/FF))
                    (RETURN T))))
       END-IDX))

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :CANONICAL-LAST-LINE) (&AUX LINE)
  (SETQ LINE (CREATE-LINE 'ART-STRING 1 NIL))
  (SETF (CHAR LINE 0) #\)
  LINE)

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :NEW-HEADER-AND-TRAILER) ()
  (VALUES "" #\NewLine))

;; Our goal state is  Return  <end-bp> Return <real-end-bp> text-of-next-message
(DEFMETHOD (ITS-MAIL-FILE-MIXIN :UPDATE-MSG-END) (MSG &OPTIONAL FOR-APPEND-P)
  (DECLARE (IGNORE FOR-APPEND-P))
  (LET ((END-LINE (BP-LINE (MSG-END-BP MSG)))
        (REAL-END-BP (MSG-REAL-END-BP MSG)))
    ;; Other mail file formats leave the end-bp and the real-end-bp on the same line.
    ;; Fix that.
    (WHEN (EQ END-LINE (BP-LINE REAL-END-BP))
      (IF (MEMBER (LINE-PREVIOUS END-LINE) '("" ""))
          (SETQ END-LINE (LINE-PREVIOUS END-LINE))
        (INSERT-MOVING REAL-END-BP #\RETURN)
        (SETQ END-LINE (LINE-PREVIOUS (BP-LINE REAL-END-BP)))))
    (MOVE-BP (MSG-END-BP MSG) END-LINE 0)
    (SETF (LINE-LENGTH END-LINE) 0)
    (VECTOR-PUSH-EXTEND #\ END-LINE)))

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :PARSE-MSG-TEXT) (MSG -STATUS-)
  (PARSE-ITS-MSG-HEADERS (MSG-INTERVAL MSG) NIL NIL (GET -STATUS- :REFORMATTED)))

(DEFMETHOD (ITS-INBOX-BUFFER :BEFORE :PARSE-MSG) (MSG -STATUS-)
  MSG
  (PUTPROP -STATUS- T 'UNSEEN))

;;; RMAIL mail files
(ADD-ZMAIL-BUFFER-FLAVOR 'RMAIL-FILE-BUFFER "Rmail")

(DEFFLAVOR RMAIL-FILE-BUFFER () (ITS-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))

(DEFMETHOD (RMAIL-FILE-BUFFER :FORMAT-NAME) () "Rmail")

(DEFMETHOD (RMAIL-FILE-BUFFER :AFTER :INIT) (PLIST)
  ;; If APPEND-P, flush the *APPEND* line from the stream, it is not part of a message.
  (AND (GET PLIST :APPEND-P) STREAM
       (INSERT-LINE-WITH-LEADER (SEND STREAM :LINE-IN LINE-LEADER-SIZE)
                                (BP-LINE FIRST-BP))))

(DEFMETHOD (RMAIL-FILE-BUFFER :SETTABLE-OPTIONS) ()
  '(:APPEND))

(DEFMETHOD (RMAIL-FILE-BUFFER :FIRST-MSG-BP) ()
  (LET* ((LINE (BP-LINE FIRST-BP)))
    (IF (STRING-EQUAL LINE "*APPEND*")
        (CREATE-BP (LINE-NEXT LINE) 0)
      FIRST-BP)))

(DEFMETHOD (RMAIL-FILE-BUFFER :UPDATE-OPTIONS-IN-FILE) ()
  (LET* ((LINE (BP-LINE FIRST-BP))
         (APPEND-P (GET (LOCF OPTIONS) :APPEND)))
    (COND ((EQ (STRING-EQUAL LINE "*APPEND*") APPEND-P))
          (APPEND-P
           (INSERT FIRST-BP "*APPEND*
"))
          (T
           (DELETE-INTERVAL FIRST-BP (BEG-LINE FIRST-BP 1 T) T)))))

;;; BABYL mail files
(ADD-ZMAIL-BUFFER-FLAVOR 'BABYL-MAIL-FILE-BUFFER "Babyl")

;;; Limits of Babyl file formats supported here
(DEFPARAMETER *LOWEST-BABYL-VERSION* 4)
(DEFPARAMETER *HIGHEST-BABYL-VERSION* 5)

(DEFFLAVOR BABYL-MAIL-FILE-BUFFER () (ITS-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :FORMAT-NAME) () "Babyl")

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :SETTABLE-OPTIONS) ()
  '(:APPEND :REVERSE-NEW-MAIL :VERSION :MAIL :OWNER :SORT :DELETE-EXPIRED
    :|NO REFORMATION| :SUMMARY-WINDOW-FORMAT :GMSGS-HOST))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :POSSIBLE-OPTIONS) ()
  '(:APPEND :BABYL-P :|NO REFORMATION| :REVERSE-NEW-MAIL :VERSION
    :MAIL :OWNER :SORT :DELETE-EXPIRED :KEYWORDS :KEYWORDS-STRING
    :SUMMARY-WINDOW-FORMAT :GMSGS-HOST))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :STICKY-OPTIONS) ()
  (SOME-PLIST OPTIONS '(:APPEND :BABYL-P)))

;;; Read the options section of the mail file
(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :AFTER :INIT) (PLIST)
  (IF STREAM
      (SETQ OPTIONS (PARSE-BABYL-OPTIONS STREAM SELF))
      (OR (GET (LOCF OPTIONS) :VERSION)
          (PUTPROP (LOCF OPTIONS) *HIGHEST-BABYL-VERSION* :VERSION))
      (AND (GET PLIST :NEW-PRIMARY-P)
           (NOT (GET (LOCF OPTIONS) :MAIL))
           (PUTPROP (LOCF OPTIONS) (NCONS (SEND PATHNAME :NEW-MAIL-PATHNAME)) :MAIL))
      (INSERT LAST-BP #\)))

(DEFUN PARSE-BABYL-OPTIONS (STREAM INTERVAL)
  (FS::SET-DEFAULT-PATHNAME (SEND STREAM :PATHNAME) *ZMAIL-PATHNAME-DEFAULTS*)
  (DO ((END-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL)))
       (LINE)
       (LIST NIL))
      (NIL)
    (SETQ LINE (SEND STREAM :LINE-IN LINE-LEADER-SIZE))
    (INSERT-LINE-WITH-LEADER LINE END-LINE)
    (AND (STRING-SEARCH-CHAR #\ LINE) (RETURN LIST))
    (SETQ LIST (APPEND LIST (OPTION-FROM-STRING LINE)))))

(DEFPARAMETER *OPTION-SPECIAL-CHARS*
        '(#/( #/" #// #/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
  "A list of (real) characters to be handled specially in Babyl format")

;;; Parse a single line of a babyl option or an unparsed message header
(DEFUN OPTION-FROM-STRING (STRING &AUX I TYPE PARSE-FUNCTION PROP)
  (SETQ I (STRING-SEARCH-CHAR #\: STRING)
        TYPE (INTERN (STRING-UPCASE (NSUBSTRING STRING 0 I)) ""))
  (AND I (SETQ I (OR (STRING-SEARCH-NOT-SET '(#\SP #\TAB) STRING (SETQ I (1+ I)))
                     (STRING-LENGTH STRING))))
  (IF (SETQ PARSE-FUNCTION (GET TYPE 'BABYL-OPTION-PARSER))
      (FUNCALL PARSE-FUNCTION TYPE STRING I)
    (COND ((NULL I)
           (SETQ PROP T))
          ((MEMQ (CHAR STRING I) *OPTION-SPECIAL-CHARS*)
           (LET ((*PACKAGE* (FIND-PACKAGE 'KEYWORD))
                 (*READ-BASE* 10.))
             (SETQ PROP (READ-FROM-STRING STRING NIL I))))
          (T
           (SETQ PROP (SUBSTRING STRING I))))
    (LIST TYPE PROP)))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :UPDATE-OPTIONS-IN-FILE) (&AUX PLIST)
  (FS::SET-DEFAULT-PATHNAME PATHNAME *ZMAIL-PATHNAME-DEFAULTS*)
  (SETQ PLIST (LOCF OPTIONS))
  ;; Move this to the first
  (COND ((OR (NEQ (CAAR PLIST) :BABYL-P) (NEQ (CADAR PLIST) T))
         (REMPROP PLIST :BABYL-P)
         (PUTPROP PLIST T :BABYL-P)))
  (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT LINE))
       (DONE NIL)
       (PROPS))
      ((STRING-SEARCH #\ LINE)
       (LOOP FOR (IND PROP) ON (CDR PLIST) BY 'CDDR
             WITH BP = (CREATE-BP LINE 0)
             WHEN (AND PROP
                       (NOT (MEMQ IND DONE))
                       (GETL IND '(BABYL-OPTION-PARSER BABYL-OPTION-PRINTER BABYL-OPTION-P)))
             DO (SETQ LINE (STRING-FROM-OPTION IND PLIST)
                      BP (INSERT (INSERT BP LINE) #\NewLine))
                (LOOP FOR IND IN (OPTION-FROM-STRING LINE) BY 'CDDR
                      DO (PUSH IND DONE))))
    (SETQ PROPS (OPTION-FROM-STRING LINE))
    (AND (LOOP FOR (IND PROP) ON PROPS BY 'CDDR
               UNLESS (EQUAL PROP (GET PLIST IND))
               RETURN T)                        ;Not still the same
         (IF (NOT (LOOP FOR (IND PROP) ON PROPS BY 'CDDR
                        WHEN (GET PLIST IND)
                        RETURN T))              ;All properties NIL
             (LET ((BP (CREATE-BP LINE 0)))
               (DELETE-INTERVAL BP (BEG-LINE BP 1 T) T))
             (MUNG-NODE (LINE-NODE LINE))
             (SETF (LINE-LENGTH LINE) 0)
             (STRING-FROM-OPTION (CAR PROPS) PLIST LINE)))
    (LOOP FOR IND IN PROPS BY 'CDDR
          DO (PUSH IND DONE))))

;;; Convert a message header into a string
(DEFUN STRING-FROM-OPTION (PROP PLIST &OPTIONAL STRING &AUX VAL TEM)
  (OR STRING (SETQ STRING (MAKE-EMPTY-STRING 40)))
  (SETQ VAL (GET PLIST PROP))
  (WITH-OUTPUT-TO-STRING (STREAM STRING)
    (COND ((SETQ TEM (GET PROP 'BABYL-OPTION-PRINTER))
           (FUNCALL TEM STREAM PROP VAL PLIST))
          (T
           (FORMAT STREAM "~:" PROP)
           (COND ((NEQ VAL T)
                  (FUNCALL STREAM :TYO #\:)
                  (LET ((*PRINT-BASE* 10.) (*NOPOINT T) (*PRINT-RADIX* NIL))
                    (FUNCALL (IF (AND (STRINGP VAL)
                                      (NOT (MEMQ (CHAR VAL 0) *OPTION-SPECIAL-CHARS*))
                                      (NOT (STRING-SEARCH-SET '(#\SP #\TAB) VAL)))
                                 #'PRINC #'PRIN1)
                             VAL STREAM)))))))
  STRING)

;;; The options themselves
(DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :BABYL-P)

(DEFUN (:|BABYL OPTIONS| BABYL-OPTION-PARSER) (&REST IGNORE)
  '(:BABYL-P T))

(DEFUN (:BABYL-P BABYL-OPTION-PRINTER) (STREAM &REST IGNORE)
  (FORMAT STREAM "Babyl Options:"))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :VERSION 5 :NUMBER)

(DEFUN (:VERSION BABYL-OPTION-PARSER) (IGNORE STRING START &AUX VERSION)
  (SETQ VERSION (PARSE-NUMBER STRING START))
  (AND (OR (NULL VERSION)
           (< VERSION *LOWEST-BABYL-VERSION*)
           (> VERSION *HIGHEST-BABYL-VERSION*))
       (CERROR T NIL NIL "Babyl version is ~D, not supported by this version of ZMail"
               VERSION))
  `(:VERSION ,VERSION))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :|NO REFORMATION| NIL :BOOLEAN)
(DEFPROP :|NO REFORMATION| T BABYL-OPTION-P)

(DEFINE-SETTABLE-MAIL-FILE-OPTION :GMSGS-HOST NIL :STRING-OR-NIL)
(DEFPROP :GMSGS-HOST T BABYL-OPTION-P)

(DEFINE-SETTABLE-MAIL-FILE-OPTION :OWNER NIL :STRING-OR-NIL)

(DEFPROP :OWNER T BABYL-OPTION-P)

(DEFPROP :STRING-OR-NIL (PRINT-STRING-OR-NIL READ-STRING-OR-NIL)
         TV::CHOOSE-VARIABLE-VALUES-KEYWORD)

(DEFUN PRINT-STRING-OR-NIL (STRING STREAM)
  (AND STRING
       (SEND STREAM :STRING-OUT STRING)))

(DEFUN READ-STRING-OR-NIL (STREAM &AUX STRING)
  (SETQ STRING (READLINE STREAM))
  (AND (PLUSP (STRING-LENGTH STRING))
       STRING))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :MAIL NIL :PATHNAME-LIST)

(DEFPROP :MAIL PATHNAME-LIST-OPTION-PARSER BABYL-OPTION-PARSER)

(DEFUN PATHNAME-LIST-OPTION-PARSER (TYPE STRING START)
  (DO ((I START (1+ J))
       (J)
       (PATHNAME-LIST NIL))
      (NIL)
    (OR (SETQ I (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* STRING I))
        (RETURN NIL))
    (SETQ J (STRING-SEARCH-CHAR #\, STRING I))
    (PUSH (FS::MERGE-PATHNAME-DEFAULTS (NSUBSTRING STRING I J) *ZMAIL-PATHNAME-DEFAULTS*)
          PATHNAME-LIST)
    (OR J (RETURN (LIST TYPE (NREVERSE PATHNAME-LIST))))))

(DEFPROP :MAIL PATHNAME-LIST-OPTION-PRINTER BABYL-OPTION-PRINTER)

(DEFUN PATHNAME-LIST-OPTION-PRINTER (STREAM PROP PATHNAME-LIST IGNORE)
  (FORMAT STREAM "~:: ~{~A~^, ~}" PROP PATHNAME-LIST))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :REVERSE-NEW-MAIL NIL :BOOLEAN)

(DEFUN (:APPEND BABYL-OPTION-PARSER) (IGNORE STRING START &AUX APPEND REVERSE)
  (IF (NULL START)                              ;Append<nl>
      (SETQ APPEND T)
      (LET ((N (PARSE-NUMBER STRING START NIL 8)))
        (SETQ APPEND (BIT-TEST N 1)
              REVERSE (BIT-TEST N 2))))
  `(:APPEND ,APPEND :REVERSE-NEW-MAIL ,REVERSE))

(DEFPROP :APPEND PRINT-APPEND-AND-REVERSE-NEW-MAIL BABYL-OPTION-PRINTER)
(DEFPROP :REVERSE-NEW-MAIL PRINT-APPEND-AND-REVERSE-NEW-MAIL BABYL-OPTION-PRINTER)

(DEFUN PRINT-APPEND-AND-REVERSE-NEW-MAIL (STREAM IGNORE IGNORE PLIST &AUX (BITS 0))
  (AND (GET PLIST :APPEND)
       (SETQ BITS (LOGIOR BITS 1)))
  (AND (GET PLIST :REVERSE-NEW-MAIL)
       (SETQ BITS (LOGIOR BITS 2)))
  (FORMAT STREAM "Append:~O" BITS))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :SUMMARY-WINDOW-FORMAT *DEFAULT-SUMMARY-TEMPLATE* :SEXP)

(DEFPROP :SUMMARY-WINDOW-FORMAT SEXP-OPTION-PARSER BABYL-OPTION-PARSER)

(DEFUN SEXP-OPTION-PARSER (TYPE STRING START)
  `(,TYPE ,(READ-FROM-STRING STRING NIL START)))

(DEFPROP :SUMMARY-WINDOW-FORMAT SEXP-OPTION-PRINTER BABYL-OPTION-PRINTER)

(DEFUN SEXP-OPTION-PRINTER (STREAM PROP SEXP IGNORE)
  (FORMAT STREAM "~:: ~S" PROP SEXP))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :INBOX-BUFFER) (&OPTIONAL NEW-PATHNAME DELETE-P)
  (MAKE-INBOX-BUFFER
    (FUNCALL PATHNAME :INBOX-BUFFER-FLAVOR)
    (IF NEW-PATHNAME
        (LIST (LIST NEW-PATHNAME NIL DELETE-P))
      (LOOP FOR NEW-PATHNAME
            IN (IF (run-gmsgs-p)
                   (CONS (SEND (ZMAIL-BUFFER-GMSGS-HOST SELF) :GMSGS-PATHNAME)
                         (GET (LOCF OPTIONS) :MAIL))
                 (GET (LOCF OPTIONS) :MAIL))
            COLLECT (LIST NEW-PATHNAME
                          (FUNCALL NEW-PATHNAME :NEW-TYPE
                                   (SEND NEW-PATHNAME
                                            :ZMAIL-TEMP-FILE-NAME))
                          T)))
    SELF))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :BEFORE :PARSE-MSG) (MSG -STATUS-)
  (LET* ((START-BP (MSG-START-BP MSG))
         (END-BP (MSG-END-BP MSG))
         (REAL-START-LINE (BP-LINE (MSG-REAL-START-BP MSG)))
         (END-LINE (BP-LINE END-BP))
         (START-LINE REAL-START-LINE))
    (DO () ((NOT (LINE-BLANK-P START-LINE)))
      (SETQ START-LINE (LINE-NEXT START-LINE)))
    (FUNCALL (IF (< (GET (LOCF OPTIONS) :VERSION) 5)
                 #'PARSE-MSG-OLD-BABYL-STATUS-LINE
               #'PARSE-MSG-NEW-BABYL-STATUS-LINE)
             START-LINE -STATUS-)
    (DO ((LINE START-LINE (LINE-NEXT LINE)))
        ((EQ LINE END-LINE))
      (COND ((STRING-EQUAL LINE "*** EOOH ***")
             (SETQ START-LINE LINE)
             (RETURN NIL))))
    (SETQ END-LINE (LINE-NEXT START-LINE))
    ;;Make lines in the header area point to MSG-REAL-INTERVAL rather than
    ;;MSG-INTERVAL.
    (DO ((LINE REAL-START-LINE (LINE-NEXT LINE)))
        ((EQ LINE END-LINE))
      (SETF (LINE-NODE LINE) *INTERVAL*))
    (MOVE-BP START-BP END-LINE 0)))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :AFTER :PARSE-MSG) (MSG -STATUS-)
  (send self :reformat-msg msg -status-))

(defmethod (babyl-mail-file-buffer :reformat-msg) (msg -status-)
  (OR (GET (LOCF OPTIONS) :|NO REFORMATION|)
      (GET -STATUS- 'REFORMATTED)
      (WHEN (AND (GET -STATUS- 'HEADERS-END-BP)
                 *DEFAULT-REFORMATTING-TEMPLATE*)
        (UNLESS (TYPEP (FSYMEVAL *DEFAULT-REFORMATTING-TEMPLATE*) :COMPILED-FUNCTION)
          (COMPILE *DEFAULT-REFORMATTING-TEMPLATE*))
        ;; First copy the original header.
        (INSERT-INTERVAL (FORWARD-LINE (INTERVAL-FIRST-BP (MSG-INTERVAL MSG)) -1)
                         (INTERVAL-FIRST-BP (MSG-INTERVAL MSG))
                         (GET -STATUS- 'HEADERS-END-BP)
                         T)
        (PUTPROP (LOCF (MSG-STATUS MSG)) T 'REFORMATTED)
        (SEND SELF :UPDATE-MSG-OPTIONS-IN-FILE MSG T)
        (FUNCALL *DEFAULT-REFORMATTING-TEMPLATE* (MSG-INTERVAL MSG) (LIST MSG)))))

(defmethod (babyl-mail-file-buffer :after :new-msg) (msg)
  (send self :reformat-msg msg (assure-msg-parsed msg)))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :NEW-HEADER-AND-TRAILER) ()
  (VALUES "
*** EOOH ***
"
          #\NewLine))

;; Our goal state is  Return  <end-bp> Return <real-end-bp> text-of-next-message
(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :UPDATE-MSG-END) (MSG &OPTIONAL FOR-APPEND-P)
  (LET ((END-LINE (BP-LINE (MSG-END-BP MSG)))
        (REAL-END-BP (MSG-REAL-END-BP MSG)))
    ;; Other mail file formats leave the end-bp and the real-end-bp on the same line.
    ;; Fix that.
    (WHEN (EQ END-LINE (BP-LINE REAL-END-BP))
      (IF (MEMBER (LINE-PREVIOUS END-LINE) '("" ""))
          (SETQ END-LINE (LINE-PREVIOUS END-LINE))
        (INSERT-MOVING REAL-END-BP #\RETURN)
        (SETQ END-LINE (LINE-PREVIOUS (BP-LINE REAL-END-BP)))))
    (MOVE-BP (MSG-END-BP MSG) END-LINE 0)
    (SETF (LINE-LENGTH END-LINE) 0)
    (VECTOR-PUSH-EXTEND #\ END-LINE)
    (IF (NOT (AND (NOT FOR-APPEND-P)
                  (EQ (BP-LINE REAL-END-BP) (BP-LINE LAST-BP))))
        (VECTOR-PUSH-EXTEND #\Page END-LINE))))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :BEFORE :LOADING-DONE) (&AUX TEM)
  (AND (PLUSP (SETQ TEM (ARRAY-ACTIVE-LENGTH ARRAY)))
       (SEND SELF :UPDATE-MSG-END (AREF ARRAY (1- TEM)))))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :BEFORE :SET-OPTIONS) (NEW-OPTIONS)
  (AND ( (GET (LOCF OPTIONS) :VERSION)
          (GET (LOCF NEW-OPTIONS) :VERSION))
       (DOMSGS (MSG SELF)
         (SEND SELF :UPDATE-MSG-OPTIONS-IN-FILE MSG))))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :FIRST-MSG-BP) ()
  (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT LINE)))
      ((STRING-SEARCH #\ LINE)
       ;; If this used to standalone, assume about to have new messages
       (AND (= (LINE-LENGTH LINE) 1)
            (VECTOR-PUSH-EXTEND #\Page LINE))
       (LET ((-NEXT- (LINE-NEXT LINE)))
         (IF -NEXT- (CREATE-BP -NEXT- 0) (CREATE-BP LINE (LINE-LENGTH LINE)))))))

;;; Handling of babyl status line at start of message.  Format is:
;;; <status-line>  ::= <reformed-bit> "," <basic-labels> "," <user-labels>
;;; <basic-labels> ::= (<Space> <label-name> ",")*
;;; <user-labels>  ::= (<Space> <label-name> ",")*

(DEFUN PARSE-MSG-NEW-BABYL-STATUS-LINE (LINE STATUS &AUX KEYWORDS)
  (DO ((I 0 (1+ J))
       (STATE 0)                                ;0 - reformatted, 1 - basic-labels,
                                                ;2 - user-labels
       (LEN (ARRAY-ACTIVE-LENGTH LINE))
       (J) (STR) (TEM))
      (( I LEN))
    (OR (SETQ J (STRING-SEARCH-CHAR #\, LINE I LEN))
        (RETURN))
    (SETQ STR (SUBSTRING LINE I J))
    ;; *** Temporary ***
    (AND (EQUALP STR "badHeader")
         (SETQ STR "bad-header"))
    ;; *** End Temporary
    (CASE STATE
      (0
       (PUTPROP STATUS (NOT (STRING-EQUAL STR "0")) 'REFORMATTED)
       (SETQ STATE 1))
      (1
       (OR (SETQ TEM (CDR (ASS #'STRING-EQUAL STR *SAVED-INTERNAL-PROPERTIES-ALIST*)))
           (ZMAIL-ERROR "Bad status line ~A" LINE))
       (PUTPROP STATUS T TEM))
      (2
       (COND ((NOT (SETQ TEM (ASS #'STRING-EQUAL STR *KEYWORD-ALIST*)))
              (SETQ TEM (INTERN (STRING-UPCASE STR) ""))
              (SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS (CONS STR TEM)))))
             (T (SETQ TEM (CDR TEM))))
       (PUSH TEM KEYWORDS)))
    (INCF J)
    (AND (= J LEN) (RETURN))
    (CASE (CHAR LINE J)
      (#/,
       (AND (> (SETQ STATE (1+ STATE)) 2)
            (RETURN))
       (SETQ J (1+ J)))
      (#/Space)
      (OTHERWISE
       (ZMAIL-ERROR "Bad status line ~A" LINE))))
  (COND (KEYWORDS
         (SETQ KEYWORDS (NREVERSE KEYWORDS))
         (PUTPROP STATUS KEYWORDS 'KEYWORDS)
         (PUTPROP STATUS (STRING-FROM-KEYWORDS KEYWORDS) 'KEYWORDS-STRING))))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE)
           (MSG &OPTIONAL NOPARSE &AUX MSG-STATUS BP LINE)
  (SETQ MSG-STATUS (IF NOPARSE (LOCF (MSG-STATUS MSG)) (ASSURE-MSG-PARSED MSG))
        BP (MSG-REAL-START-BP MSG)
        LINE (BP-LINE BP))
  (SETF (LINE-LENGTH LINE) 0)
  (FUNCALL (IF (< (GET (LOCF OPTIONS) :VERSION) 5)
               #'UPDATE-MSG-OLD-BABYL-STATUS-LINE
               #'UPDATE-MSG-NEW-BABYL-STATUS-LINE)
           LINE MSG-STATUS)
  (MUNG-BP-LINE-AND-INTERVAL BP))

(DEFUN UPDATE-MSG-NEW-BABYL-STATUS-LINE (LINE STATUS)
  (VECTOR-PUSH-EXTEND (IF (GET STATUS 'REFORMATTED) #\1 #\0) LINE)
  (VECTOR-PUSH-EXTEND #\, LINE)
  (DO ((LIST *SAVED-INTERNAL-PROPERTIES-ALIST* (CDR LIST))
       (KEY))
      ((NULL LIST))
    (SETQ KEY (CDAR LIST))
    (COND ((GET STATUS KEY)
           (VECTOR-PUSH-EXTEND #\SP LINE)
           (APPEND-TO-ARRAY LINE (CAAR LIST))
           (VECTOR-PUSH-EXTEND #\, LINE))))
  (VECTOR-PUSH-EXTEND #\, LINE)
  (DOLIST (KEYWORD (GET STATUS 'KEYWORDS))
    (VECTOR-PUSH-EXTEND #\SP LINE)
    (APPEND-TO-ARRAY LINE (CAR (OR (RASSQ KEYWORD *KEYWORD-ALIST*)
                                   (RASS 'STRING-EQUAL KEYWORD *KEYWORD-ALIST*))))
    (VECTOR-PUSH-EXTEND #\, LINE)))

;;; This is settable, but not in the standard way
(DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :KEYWORDS)
(DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :KEYWORDS-STRING)

(DEFPROP :KEYWORDS PARSE-KEYWORDS-LIST BABYL-OPTION-PARSER)
(DEFPROP :LABELS PARSE-KEYWORDS-LIST BABYL-OPTION-PARSER)

(DEFUN PARSE-KEYWORDS-LIST (IGNORE STRING &OPTIONAL (START 0) END
                                          &AUX KEYWORDS-STRING KEYWORDS)
  (SETQ KEYWORDS-STRING (SUBSTRING STRING START END))
  (DO ((I0 0 (1+ I1))
       (I1) (I2) (STR))
      (NIL)
    (OR (SETQ I0 (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* KEYWORDS-STRING I0))
        (RETURN NIL))
    (SETQ I1 (STRING-SEARCH-CHAR #\, KEYWORDS-STRING I0))
    (AND (SETQ I2 (STRING-SEARCH-CHAR #\= KEYWORDS-STRING I0 I1))
         (SETQ I0 (1+ I2)))
    (SETQ STR (SUBSTRING KEYWORDS-STRING I0 I1))
    (PUSH (OR (ASS 'EQUALP STR *KEYWORD-ALIST*)
              (LET* ((KEY (INTERN (STRING-UPCASE STR) ""))
                     (ELEM (CONS STR KEY)))
                (SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS ELEM)))
                ELEM))
          KEYWORDS)
    (OR I1 (RETURN NIL)))
  ;;Avoid writing out an empty labels line.
  (AND (NULL KEYWORDS) (SETQ KEYWORDS-STRING NIL))
  `(:KEYWORDS ,(NREVERSE KEYWORDS) :KEYWORDS-STRING ,KEYWORDS-STRING))

;;; This updates the string of all keywords at the head of the file
;;; The idea is that old keywords that are still valid are kept in the old order, and new
;;; ones appended at the end.
(DEFUN (:KEYWORDS BABYL-OPTION-PRINTER) (STREAM IGNORE KEYWORDS PLIST &AUX STRING COMMA-FLAG)
  (SETQ STRING (MAKE-EMPTY-STRING 25.))
  (LET ((KEYWORDS-STRING (GET PLIST :KEYWORDS-STRING)))
    (AND KEYWORDS-STRING
         (DO ((I0 0 (1+ I1))
              (I1) (I2) (STR) (KEY) (ELEM))
             (NIL)
           (SETQ I1 (STRING-SEARCH-CHAR #\, KEYWORDS-STRING I0)
                 I2 (STRING-SEARCH-CHAR #\= KEYWORDS-STRING I0 I1)
                 STR (SUBSTRING KEYWORDS-STRING (IF I2 (1+ I2) I0) I1)
                 KEY (INTERN (STRING-UPCASE STR) ""))
           (COND ((SETQ ELEM (RASSQ KEY KEYWORDS))
                  (SETQ KEYWORDS (REMQ ELEM KEYWORDS))
                  (AND COMMA-FLAG (VECTOR-PUSH-EXTEND #\, STRING))
                  (SETQ COMMA-FLAG T)
                  (APPEND-TO-ARRAY STRING KEYWORDS-STRING I0 I1)))
           (OR I1 (RETURN NIL)))))
  (DO ((AL KEYWORDS (CDR AL)))
      ((NULL AL))
    (AND COMMA-FLAG (VECTOR-PUSH-EXTEND #\, STRING))
    (SETQ COMMA-FLAG T)
    (APPEND-TO-ARRAY STRING (CAAR AL)))
  (PUTPROP PLIST STRING :KEYWORDS-STRING)
  (SEND STREAM :STRING-OUT (IF ( (GET PLIST :VERSION) 5) "Labels:" "Keywords:"))
  (SEND STREAM :STRING-OUT STRING))

;;; *** BEGINNING OF OLD BABYL STUFF ***
(DEFVAR *BABYL-BIT-MASK-PROPERTIES*
        '(REFORMATTED                           ;1
          UNSEEN                                ;2 - really stored the other way
          LOSING-HEADERS                        ;4
          ANSWERED                              ;10
          FILED                                 ;20
          ))

(DEFUN PARSE-MSG-OLD-BABYL-STATUS-LINE (LINE STATUS &AUX I)
  (COND ((= (AREF LINE (SETQ I 0)) #\D)
         (PUTPROP STATUS T 'DELETED)
         (SETQ I 1)))
  (DO ((BITS (LOGXOR (PARSE-NUMBER LINE I NIL 8) 2))    ;Check SEEN, not UNSEEN
       (L *BABYL-BIT-MASK-PROPERTIES* (CDR L))
       (N 1 (LSH N 1)))
      ((NULL L))
    (AND (BIT-TEST BITS N) (PUTPROP STATUS T (CAR L))))
  (LET ((IDX (STRING-SEARCH-CHAR #\{ LINE)))
    (AND IDX
         (MULTIPLE-VALUE-BIND (KEYWORDS STRING) (PARSE-KEYWORDS LINE IDX)
           (PUTPROP STATUS KEYWORDS 'KEYWORDS)
           (PUTPROP STATUS STRING 'KEYWORDS-STRING)))))

(DEFUN PARSE-KEYWORDS (LINE IDX &AUX (LENGTH (ARRAY-ACTIVE-LENGTH LINE)) KEYWORDS)
  (DO ((I0 IDX (STRING-SEARCH-CHAR #\{ LINE I1 LENGTH))
       (I1) (STR) (KEY))
      ((NULL I0))
    (OR (SETQ I1 (STRING-SEARCH-CHAR #\} LINE (SETQ I0 (1+ I0)) LENGTH))
        (RETURN NIL))
    (SETQ STR (SUBSTRING LINE I0 I1)
          KEY (INTERN (STRING-UPCASE STR) ""))
    (OR (RASSQ KEY *KEYWORD-ALIST*)
        ;; Keywords not officially defined go at the end of the list
        (SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS (CONS STR KEY)))))
    (PUSH KEY KEYWORDS))
  (SETQ KEYWORDS (NREVERSE KEYWORDS))
  (VALUES KEYWORDS (STRING-FROM-KEYWORDS KEYWORDS)))

(DEFUN UPDATE-MSG-OLD-BABYL-STATUS-LINE (LINE STATUS &AUX (BITS 10000))
  (DO ((L *BABYL-BIT-MASK-PROPERTIES* (CDR L))
       (N 1 (LSH N 1)))
      ((NULL L))
    (AND (GET STATUS (CAR L)) (SETQ BITS (LOGIOR BITS N))))
  (FORMAT LINE "~O" (LOGXOR BITS 2))            ;Store SEEN, not UNSEEN
  (DOLIST (KEYWORD (GET STATUS 'KEYWORDS))
    (FORMAT LINE " {~A}" (CAR (RASSQ KEYWORD *KEYWORD-ALIST*))))
  (AND (GET STATUS 'DELETED) (ASET #\D LINE 0)))

;;; *** END OF OLD BABYL STUFF ***

(DEFVAR *ZMAIL-BUFFER-SORT-ALIST*
        `(("None" :VALUE NIL)
          . ,*SORT-KEY-ALIST-1*))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :SORT NIL :MENU-ALIST
                                  "Sort predicate" *ZMAIL-BUFFER-SORT-ALIST*)

(DEFPROP :SORT MENU-ALIST-BABYL-OPTION-PARSER BABYL-OPTION-PARSER)
(DEFPROP :SORT MENU-ALIST-BABYL-OPTION-PRINTER BABYL-OPTION-PRINTER)

(DEFINE-SETTABLE-MAIL-FILE-OPTION :DELETE-EXPIRED NIL :MENU-ALIST
                                  "Delete expired messages" *YES-NO-ASK-ALIST*)

(DEFPROP :DELETE-EXPIRED MENU-ALIST-BABYL-OPTION-PARSER BABYL-OPTION-PARSER)
(DEFPROP :DELETE-EXPIRED MENU-ALIST-BABYL-OPTION-PRINTER BABYL-OPTION-PRINTER)

(DEFUN MENU-ALIST-BABYL-OPTION-PARSER (TYPE STRING START)
  (LIST TYPE (IF (NULL START) T
                 (DOLIST (ELEM (FOURTH (ASSQ TYPE *ZMAIL-BUFFER-OPTION-ALIST*)))
                   (AND (STRING-EQUAL (CAR ELEM) STRING :START1 0 :START2 START)
                        (RETURN (TV::MENU-EXECUTE-NO-SIDE-EFFECTS ELEM)))))))

(DEFUN MENU-ALIST-BABYL-OPTION-PRINTER (STREAM TYPE VALUE IGNORE)
  (FORMAT STREAM "~:~:[: ~A~]" TYPE (EQ VALUE T)
          (NAME-FROM-MENU-VALUE VALUE (FOURTH (ASSQ TYPE *ZMAIL-BUFFER-OPTION-ALIST*)))))

(DEFUN NAME-FROM-MENU-VALUE (VALUE ITEM-LIST)
  (DOLIST (ELEM ITEM-LIST)
    (AND (EQ (TV::MENU-EXECUTE-NO-SIDE-EFFECTS ELEM) VALUE)
         (RETURN (CAR ELEM)))))

;;; T(w)enex mail files.  Each message has one status line of the form
;;; <received-date>,<byte-count>;bits.  E.g.
;;; 30-Jan-81 16:53:05-EST,129;000000000001

(DEFFLAVOR TENEX-MAIL-FILE-MIXIN () ()
  :ABSTRACT-FLAVOR
  (:REQUIRED-FLAVORS ZMAIL-DISK-BUFFER))

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :FORMAT-NAME) () "Tenex mail")

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :HEADER-COMPATIBLE-MAIL-FILE-FORMATS) ()
  '("Mail" "Rmail" "Babyl" "Tenex mail"))

(DEFMETHOD (FS::TENEX-FAMILY-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM)
  (VALUES (IF (OR (NULL STREAM)
                  (LET ((FIRST-LINE (SEND STREAM :LINE-IN)))
                    (SEND STREAM :SET-POINTER 0)
                    (STRING-EQUAL FIRST-LINE "Babyl Options:")))
              ;; Babyl is the default when no stream since that is the filename
              ;; prompted.  Perhaps this should be improved?
              'BABYL-MAIL-FILE-BUFFER
              'TENEX-MAIL-FILE-BUFFER)
          T))                                   ;Always APPEND-P

(ADD-ZMAIL-BUFFER-FLAVOR 'TENEX-MAIL-FILE-BUFFER "Tenex")

(DEFFLAVOR TENEX-MAIL-FILE-BUFFER () (TENEX-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))


(DEFMETHOD (FS::TENEX-FAMILY-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-NAMES) ()
  (LIST (SEND SELF :NEW-PATHNAME :NAME (STRING-UPCASE USER-ID)
                      :TYPE "BABYL" :VERSION :NEWEST)))

(DEFMETHOD (FS::TENEX-FAMILY-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS) ()
  '(TENEX-MAIL-FILE-BUFFER BABYL-MAIL-FILE-BUFFER))

(DEFMETHOD (FS::TOPS20-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (OR (MAYBE-OVERRIDDEN-MAIL-PATHNAME SELF)
      (SEND SELF :NEW-PATHNAME :NAME "MAIL" :TYPE "TXT" :VERSION 1)))

(DEFMETHOD (FS::TENEX-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (SEND SELF :NEW-PATHNAME :NAME "MESSAGE" :TYPE "TXT" :VERSION 1))

(DEFMETHOD (SI:HOST-TOPS20-MIXIN :DO-GMSGS) (STREAM &aux result)
  (MULTIPLE-VALUE-BIND (FILE-NAME UNAME-STRING) (SEND SELF :GMSGS-PATHNAME)
    (setq result (CHAOS:SIMPLE SELF (GMSGS-CONTACT-NAME FILE-NAME UNAME-STRING)))
    (FORMAT STREAM "~&~A" (CHAOS:PKT-STRING RESULT))
    (CHAOS:RETURN-PKT RESULT)
    FILE-NAME))

(DEFMETHOD (SI:HOST-TOPS20-MIXIN :GMSGS-PATHNAME) ()
  (VALUES (SEND (FS::USER-HOMEDIR SELF) :NEW-PATHNAME
                :NAME "ZMAIL" :TYPE "TXT")
          (FS::UNAME-ON-HOST SELF)))

(DEFVAR *TENEX-BIT-MASK-PROPERTIES*
        '(UNSEEN                                ;1 - really the other way around
          DELETED                               ;2
          ALWAYS-SHOW                           ;4
          ANSWERED))                            ;10

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :BEFORE :PARSE-MSG) (MSG -STATUS- &AUX LINE COMMA-POS SEMI-POS)
  (SETQ LINE (BP-LINE (MSG-REAL-START-BP MSG)))
  (COND ((AND (PLUSP (LINE-LENGTH LINE))
              (SETQ COMMA-POS (STRING-SEARCH-CHAR #\, LINE))
              (SETQ SEMI-POS (STRING-SEARCH-CHAR #\; LINE (1+ COMMA-POS))))
         (PUTPROP -STATUS-
                  (IGNORE-ERRORS
                    (TIME::PARSE-UNIVERSAL-TIME LINE 0 COMMA-POS))
                  'RECEIVED-DATE)
         (DO ((BITS (LOGXOR (PARSE-NUMBER LINE (1+ SEMI-POS) NIL 8) 1))
              (L *TENEX-BIT-MASK-PROPERTIES* (CDR L))
              (N 1 (LSH N 1)))
             ((NULL L))
           (AND (BIT-TEST BITS N) (PUTPROP -STATUS- T (CAR L))))))
  (MOVE-BP (MSG-START-BP MSG) (LINE-NEXT LINE) 0))

(DEFMETHOD (TENEX-MAIL-FILE-BUFFER :NEW-HEADER-AND-TRAILER) ()
  (VALUES #\NewLine ""))

(DEFMETHOD (TENEX-MAIL-FILE-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE) (MSG &AUX -STATUS- BP LINE)
  (SETQ -STATUS- (ASSURE-MSG-PARSED MSG)
        BP (MSG-REAL-START-BP MSG)
        LINE (BP-LINE BP))
  (SETF (LINE-LENGTH LINE) 0)
  (LET (DAY MONTH YEAR HOURS MINUTES SECONDS DST-P
        (BITS 0))
    (MULTIPLE-VALUE (SECONDS MINUTES HOURS DAY MONTH YEAR NIL DST-P)
      (TIME::DECODE-UNIVERSAL-TIME (OR (CADR (GETL -STATUS- '(RECEIVED-DATE :DATE)))
                                      (TIME::GET-UNIVERSAL-TIME))
                                  TIME::*TIMEZONE*))
    (DO ((L *TENEX-BIT-MASK-PROPERTIES* (CDR L))
         (N 1 (LSH N 1)))
        ((NULL L))
      (AND (GET -STATUS- (CAR L)) (SETQ BITS (LOGIOR BITS N))))
    (FORMAT LINE "~D-~A-~D ~D:~2,'0D:~2,'0D-~A,~D;~12,'0O"
            DAY (TIME::MONTH-STRING MONTH :SHORT) YEAR
            HOURS MINUTES SECONDS (TIME::TIMEZONE-STRING TIME::*TIMEZONE* DST-P)
            (COUNT-PDP-10-CHARS (MSG-START-BP MSG) (MSG-REAL-END-BP MSG) T)
            (LOGXOR BITS 1)))
  (MUNG-BP-LINE-AND-INTERVAL BP))

(DEFUN COUNT-PDP-10-CHARS (FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((FIRST-LINE (BP-LINE FROM-BP))
        (FIRST-INDEX (BP-INDEX FROM-BP))
        (LAST-LINE (BP-LINE TO-BP))
        (LAST-INDEX (BP-INDEX TO-BP)))
    (COND ((EQ FIRST-LINE LAST-LINE)
           (- LAST-INDEX FIRST-INDEX))
          (T (DO ((LINE (LINE-NEXT FIRST-LINE) (LINE-NEXT LINE))
                  (I 2 (+ 2 I (LINE-LENGTH LINE))))
                 ((EQ LINE LAST-LINE)
                  (+ I (- (LINE-LENGTH FIRST-LINE) FIRST-INDEX) LAST-INDEX)))))))

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :MAIL-FILE-REPARSABLE-P) () T)

;;; Messages on tenex has a byte count at the front

;;; The byte count can be screwed up by rubouts in the file
;;; turning themselves and the next character into a single LISPM character.

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :LINE-END-OF-MSG-P) (LINE LENGTH STATE IGNORE START
                                                       &AUX (ENTRY-STATE STATE))
  (IF (AND STATE ( STATE LENGTH))
      ;; Message ends after this line, or keeps going.
      (PROGN (SETQ STATE (- STATE (+ LENGTH 2)))
             (VALUES ( STATE 0) STATE))
    ;; Message ends inside or in front of this line???
    (LET* ((COMMA-IDX (%STRING-SEARCH-CHAR #\, LINE (OR STATE 0) LENGTH))
           (SEMI-IDX
             (AND COMMA-IDX
                  (%STRING-SEARCH-CHAR #\; LINE (1+ COMMA-IDX) LENGTH))))
      (COND ((AND SEMI-IDX
                  (SETQ STATE (PARSE-NUMBER LINE (1+ COMMA-IDX) SEMI-IDX 10. T)))
             ;; This line looks like a legitimate message starter.
             ;; Now take care of possibility that message ends in middle of line.
             (UNLESS (MEMQ ENTRY-STATE '(0 NIL))
               (INSERT (CREATE-BP LINE ENTRY-STATE) #\RETURN)
               ;;Add two to the byte count of the message that is ending,
               ;;so that it will count the Return just inserted.
               (LET* ((START-COMMA-IDX (%STRING-SEARCH-CHAR #\, START 0 (LINE-LENGTH START)))
                      (START-SEMI-IDX
                        (AND START-COMMA-IDX
                             (%STRING-SEARCH-CHAR #\; START
                                                  (1+ START-COMMA-IDX) (LINE-LENGTH START))))
                      (START-COUNT
                        (AND START-SEMI-IDX
                             (PARSE-NUMBER START (1+ START-COMMA-IDX) START-SEMI-IDX 10. T))))
                 (WHEN START-COUNT
                   (DELETE-INTERVAL
                     (CREATE-BP START (1+ START-COMMA-IDX))
                     (CREATE-BP START START-SEMI-IDX)
                     T)
                   (INSERT (CREATE-BP START (1+ START-COMMA-IDX))
                           (FORMAT NIL "~d" (+ 2 START-COUNT))))))
             (VALUES (NOT (NULL ENTRY-STATE))
                     STATE))
            (T
             ;; If we cannot parse out a byte count on this line,
             ;; set the state to 1, which will make us look at each line
             ;; till we find one that looks semi-right.
             (VALUES NIL 1))))))

(DEFMETHOD (FS::TENEX-FAMILY-PATHNAME-MIXIN :INBOX-BUFFER-FLAVOR) ()
  'TENEX-INBOX-BUFFER)

(DEFMETHOD (FS::TOPS20-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  (STRING-APPEND "_ZMAIL_" (SEND SELF :TYPE)))

(DEFMETHOD (FS::TENEX-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  (STRING-APPEND "-ZMAIL-" (SEND SELF :TYPE)))

(DEFFLAVOR TENEX-INBOX-BUFFER () (TENEX-MAIL-FILE-MIXIN INBOX-BUFFER))

;;; Unix mail files.

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM &AUX FLAVOR)
  (IF (NULL STREAM)
      (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER)
    (LET ((FIRST-LINE (SEND STREAM :LINE-IN)))
      (SEND STREAM :SET-POINTER 0)
      (IF (STRING-EQUAL FIRST-LINE "Babyl Options:")
          ;; Looks like a babyl file
          (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER)
        ;; Default is unix mail file
        (SETQ FLAVOR 'UNIX-MAIL-FILE-BUFFER))))
  (VALUES FLAVOR T))

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-NAMES) ()
  (LIST (SEND SELF :NEW-PATHNAME :NAME USER-ID :TYPE :BABYL :VERSION :NEWEST)
        (SEND SELF :NEW-PATHNAME :RAW-NAME "mbox" :TYPE :UNSPECIFIC :VERSION :NEWEST)))

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS) ()
  '(BABYL-MAIL-FILE-BUFFER UNIX-MAIL-FILE-BUFFER))

(DEFFLAVOR UNIX-MAIL-FILE-MIXIN () ()
  :ABSTRACT-FLAVOR
  (:REQUIRED-FLAVORS ZMAIL-DISK-BUFFER))

(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :FORMAT-NAME) () "Unix mail")

(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :MAIL-FILE-REPARSABLE-P) () T)

(ADD-ZMAIL-BUFFER-FLAVOR 'UNIX-MAIL-FILE-BUFFER "Unix")

(DEFFLAVOR UNIX-MAIL-FILE-BUFFER () (UNIX-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))

(DEFCONST *UNIX-FROM-MARKER* "From ")

(DEFMETHOD (UNIX-MAIL-FILE-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE) (MSG)
  (LET* ((-STATUS- (ASSURE-MSG-PARSED MSG))
         (OLD-FROM (FIRST (GET -STATUS- 'UNIX-FROM-HEADER)))
         (FROM (GET -STATUS- :FROM)))
    (OR (and (listp from) (listp old-from)
             (LOOP FOR X IN FROM AND Y IN OLD-FROM
                   ALWAYS (LOOP FOR IND IN '(:NAME :HOST)
                                ALWAYS (EQUAL (GET (LOCF X) IND) (GET (LOCF Y) IND)))))
        (LET* ((RECEIVED-DATE (GET -STATUS- 'RECEIVED-DATE))
               (START-BP (MSG-START-BP MSG))
               (LINE (BP-LINE START-BP)))
          (SETQ OLD-FROM (LIST FROM RECEIVED-DATE))
          (IF (STRING-EQUAL-START LINE *UNIX-FROM-MARKER*)
              (SETF (LINE-LENGTH LINE) 0)
              (INSERT START-BP #\NewLine))
          (WITH-OUTPUT-TO-STRING (-STREAM- LINE)
            (SEND -STREAM- :STRING-OUT *UNIX-FROM-MARKER*)
            (PRINT-ADDRESS-LIST FROM -STREAM-)
            (AND RECEIVED-DATE
                 (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
                     (TIME::DECODE-UNIVERSAL-TIME RECEIVED-DATE)
                   (FORMAT -STREAM- "  ~A ~A ~2D ~2,'0D:~2,'0D:~2,'0D ~D"
                           (TIME::DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK :SHORT)
                           (TIME::MONTH-STRING MONTH :SHORT)
                           DAY HOURS MINUTES SECONDS (+ YEAR 1900.)))))))))

(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :PARSE-MSG-TEXT) (MSG IGNORE &AUX UNIX-HEADER NEWSTAT)
  (LET ((START-BP (MSG-START-BP MSG)))
    (LET ((LINE (BP-LINE START-BP)))
      (COND ((STRING-EQUAL-START LINE *UNIX-FROM-MARKER*)
             (SETQ UNIX-HEADER (PARSE-UNIX-FROM-HEADER start-bp))
             (PUTPROP (LOCF NEWSTAT) UNIX-HEADER 'UNIX-FROM-HEADER)
             (SETQ START-BP (BEG-LINE START-BP 1)))))
    (MULTIPLE-VALUE-BIND (TEM STOP-BP)
        (PARSE-HEADERS-INTERVAL START-BP (MSG-END-BP MSG) T T)
      (AND UNIX-HEADER
           (LET ((PLIST (LOCF TEM)))
             (PUTPROP PLIST (SECOND UNIX-HEADER) 'RECEIVED-DATE)
             (OR (GET PLIST :DATE)
                 (PUTPROP PLIST (SECOND UNIX-HEADER) :DATE))
             (OR (GET PLIST :FROM)
                 (PUTPROP PLIST (FIRST UNIX-HEADER) :FROM))))
      (VALUES (APPEND TEM NEWSTAT) STOP-BP))))

(DEFUN PARSE-UNIX-FROM-HEADER (start-bp &aux line (bp start-bp))
  ;find the last line that has either "From" or ">From"
  (do ()
      ((not (or (string-equal-start (bp-line bp) "From ")
                (string-equal-start (bp-line bp) ">From "))))
    (setq bp (beg-line bp 1 nil)))
  (cond ((not (bp-= bp start-bp))
         (setq bp (beg-line bp -1 t))
         (setq line (bp-line bp)))
        (t
         ;couldn't make sense of what's going on, do the old behavior
         (setq line (bp-line start-bp))))
  (LET ((START (STRING-LENGTH *UNIX-FROM-MARKER*))
        END)
    (SETQ END (STRING-SEARCH-CHAR #\SP LINE START))
    (DO (NEXT-END WORD)
        (())
      ;; Look at the word (between spaces) following END.
      (OR (SETQ NEXT-END (STRING-SEARCH-CHAR #\SP LINE (1+ END)))
          (RETURN))  ;Don't get screwed by malformatted line, if we run out of it.
      (SETQ WORD (SUBSTRING LINE (1+ END) NEXT-END))
      ;; If this word is a day-of-the-week abbreviation,
      ;; then it is not part of the sender, so use END, which points before it.
      (AND ( NEXT-END (+ END 4))
           (DOLIST (DAYLIST TIME::*DAYS-OF-THE-WEEK*)
             (IF (STRING-EQUAL (CAR DAYLIST) WORD :START1 0 :START2 0 :END1 (LENGTH WORD))
                 (RETURN T)))
           (RETURN))
      ;; Otherwise it is part of the sender.
      (SETQ END NEXT-END))
    (LIST (condition-case (error)
              (PARSE-ADDRESSES LINE START END)
            (error (send error :report-string)))
          (AND END
               (CONDITION-CASE (ERROR)
                   (TIME::PARSE-UNIVERSAL-TIME LINE (+ END 1) (string-search "remote" line))
                 (ERROR (SEND ERROR :REPORT-STRING)))))))

;; Copied from LAD: RELEASE-3.ZMAIL; MFHOST.LISP#66 on 2-Oct-86 03:04:07
(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :LINE-END-OF-MSG-P) (LINE IGNORE STATE EOF IGNORE)
  (VALUES (COND ((NULL STATE) NIL)
                (EOF (LINE-LENGTH LINE))
                ((and (STRING= LINE *UNIX-FROM-MARKER* :END1 (string-LENGTH *UNIX-FROM-MARKER*))
                      ;; These other tests are neccessary because, sometimes, a ``From''
                      ;; can appear at the beginning of a line (probably a Unix bug).
                      (let ((start (string-search-char #\Space line
                                                       (+ 1 (string-length *unix-from-marker*)))))
                        (when start
                          (dolist (daylist time::*days-of-the-week*)
                            (let ((from
                                    (string-search (car daylist) line start))) ; quick d-o-w check
                              (and from
                                   (string-search-set "0123456789" line ; quick date/numbers check
                                                      (+ 1 from))
                                   (return t)))))))
                 :START-NEXT))
          T))

(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :REFORMAT-MSG-HEADER) (MSG)
  (WITH-BP (SEP (INTERVAL-FIRST-BP (MSG-INTERVAL MSG)) :MOVES)
    (LET ((STRM (INTERVAL-STREAM-INTO-BP (INTERVAL-FIRST-BP (MSG-INTERVAL MSG))))
          (RECEIVED-DATE (GET (LOCF (MSG-STATUS MSG)) 'RECEIVED-DATE)))
      (SEND STRM :STRING-OUT *UNIX-FROM-MARKER*)
      (PRINT-ADDRESS-LIST (GET (LOCF (MSG-STATUS MSG)) :FROM) STRM)
      (AND RECEIVED-DATE
           (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
               (TIME::DECODE-UNIVERSAL-TIME RECEIVED-DATE)
             (FORMAT STRM "  ~A ~A ~2D ~2,'0D:~2,'0D:~2,'0D ~D"
                     (TIME::DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK :SHORT)
                     (TIME::MONTH-STRING MONTH :SHORT)
                     DAY HOURS MINUTES SECONDS (+ YEAR 1900.))))
      (DO ((TAIL (MSG-STATUS MSG) (CDDR TAIL)))
          ((NULL TAIL))
        (WHEN (RASSQ (CAR TAIL) *HEADER-NAME-ALIST*)
          (PRINT-HEADER STRM (CADR TAIL) (CAR TAIL)))))
    (TERPRI STREAM)
    (DELETE-INTERVAL SEP (GET (LOCF (MSG-STATUS MSG)) 'HEADERS-END-BP))))

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :INBOX-BUFFER-FLAVOR) ()
  'UNIX-INBOX-BUFFER)

(defmethod (unix-mail-file-mixin :inbox-buffer) (&optional new-pathname delete-p)
  (let ((username (progn
                    ;; Just causing a file access to the host to happen, so that we can get
                    ;; the right user id.
                    (fs::user-homedir (send pathname :host))
                    ;; We downcase the name because some Unix file servers are not case-sensitive
                    ;; to the user name for the login command.
                    (string-downcase (or (fs::uname-on-host (send pathname :host))
                                         user-id)))))
    (make-inbox-buffer (send pathname :inbox-buffer-flavor)
                       (if new-pathname
                           (list (list new-pathname nil delete-p))
                         (loop for new-pathname
                               in (list (send pathname :new-pathname
                                              :raw-directory '("usr" "spool" "mail")
                                              :raw-name username :type :unspecific
                                              :version :newest)
                                        (send pathname :new-pathname
                                              :raw-directory '("usr" "mail")
                                              :raw-name username :type :unspecific
                                              :version :newest)
                                        (send pathname :new-pathname
                                              :raw-name ".mail" :type :unspecific
                                              :version :newest))
                               collect (list new-pathname
                                             (send new-pathname :new-raw-type
                                                   (send new-pathname :zmail-temp-file-name))
                                             t)))
                       self)))

;;; >> System V lossage here.
(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (OR (MAYBE-OVERRIDDEN-MAIL-PATHNAME SELF)
      (SEND SELF :NEW-PATHNAME
                    :RAW-DIRECTORY '("usr" "spool" "mail")
                    :RAW-NAME USER-ID
                    :TYPE :UNSPECIFIC :VERSION :NEWEST)))

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  "zmail")

(DEFFLAVOR UNIX-INBOX-BUFFER () (UNIX-MAIL-FILE-MIXIN INBOX-BUFFER))

(DEFMETHOD (UNIX-INBOX-BUFFER :BEFORE :PARSE-MSG) (MSG -STATUS-)
  MSG
  (PUTPROP -STATUS- T 'UNSEEN))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM &AUX FLAVOR)
  (IF (NULL STREAM)
      (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER)
    (LET ((FIRST-LINE (SEND STREAM :LINE-IN)))
      (SEND STREAM :SET-POINTER 0)
      (IF (STRING-EQUAL FIRST-LINE #\FF)
          (SETQ FLAVOR 'VMS-MAIL-FILE-BUFFER)
        ;; Doesn't look like a vms file
        (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER))))
  (VALUES FLAVOR T))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-NAMES) ()
  (LIST (SEND SELF :NEW-PATHNAME :NAME USER-ID :TYPE :BABYL :VERSION :NEWEST)))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS) ()
  '(BABYL-MAIL-FILE-BUFFER VMS-MAIL-FILE-BUFFER))

(DEFFLAVOR VMS-MAIL-FILE-MIXIN () ()
  :ABSTRACT-FLAVOR
  (:REQUIRED-FLAVORS ZMAIL-DISK-BUFFER))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :FORMAT-NAME) () "VMS mail")

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :MAIL-FILE-REPARSABLE-P) () T)

(ADD-ZMAIL-BUFFER-FLAVOR 'VMS-MAIL-FILE-BUFFER "VMS")

(DEFFLAVOR VMS-MAIL-FILE-BUFFER () (VMS-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :LINE-END-OF-MSG-P) (LINE LENGTH STATE EOFFLAG &REST IGNORE)
  (VALUES (COND ((NULL STATE) NIL)
                (EOFFLAG LENGTH)
                ((STRING-EQUAL LINE #\FF)
                 :START-NEXT))
          T))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :BEFORE :PARSE-MSG) (MSG &REST IGNORE)
  (LET ((REAL-START-LINE (BP-LINE (INTERVAL-FIRST-BP (MSG-REAL-INTERVAL MSG)))))
    (MOVE-BP (INTERVAL-FIRST-BP (MSG-INTERVAL MSG))
             (LINE-NEXT REAL-START-LINE) 0)
    (SETF (LINE-NODE REAL-START-LINE) *INTERVAL*)))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :AFTER :PARSE-MSG) (MSG &REST IGNORE)
  (LET ((LINE (LINE-PREVIOUS (BP-LINE (INTERVAL-LAST-BP (MSG-REAL-INTERVAL MSG))))))
    (MOVE-BP (INTERVAL-LAST-BP (MSG-INTERVAL MSG))
             LINE (LENGTH LINE))))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :NEW-HEADER-AND-TRAILER) ()
  (VALUES (STRING-APPEND #\Page #\NewLine) #\NewLine))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :PARSE-MSG-TEXT) (MSG IGNORE &AUX VMS-HEADER NEWSTAT STOP-BP)
  (LET ((START-BP (MSG-START-BP MSG)))
    (LET ((LINE (BP-LINE START-BP))
          (HOST (LIST (SEND (PATHNAME-HOST PATHNAME) :NAME))))
      (SETQ VMS-HEADER (PARSE-VMS-FROM-HEADER LINE))
      (PUTPROP (LOCF NEWSTAT) VMS-HEADER 'VMS-FROM-HEADER)
      (IF (EQUAL (FIRST VMS-HEADER) "CHAOSMAIL")
          (MULTIPLE-VALUE (NEWSTAT STOP-BP)
            (PARSE-HEADERS-INTERVAL (BEG-LINE START-BP 1) (MSG-END-BP MSG) T T))
        (SETQ STOP-BP (BEG-LINE START-BP 1))
        (WHEN (STRING-EQUAL (BP-LINE STOP-BP) "TO:      " :END1 4 :END2 4)
          (LET ((TEM (PARSE-VMS-TO-HEADER (BP-LINE STOP-BP) HOST)))
            (WHEN TEM
              (PUTPROP (LOCF NEWSTAT) TEM :TO))
            (SETQ STOP-BP (BEG-LINE STOP-BP 1))))
        (WHEN (STRING-EQUAL (BP-LINE STOP-BP) "SUBJ:    " :END1 6 :END2 6)
          (LET ((TEM (PARSE-VMS-SUBJECT-HEADER (BP-LINE STOP-BP))))
            (WHEN TEM
              (PUTPROP (LOCF NEWSTAT) TEM :SUBJECT))
            (SETQ STOP-BP (BEG-LINE STOP-BP 1)))))
      (LET ((PLIST (LOCF NEWSTAT)))
        (PUTPROP PLIST (SECOND VMS-HEADER) 'RECEIVED-DATE)
        (OR (GET PLIST :DATE)
            (PUTPROP PLIST (SECOND VMS-HEADER) :DATE))
        (OR (GET PLIST :FROM)
            (PUTPROP PLIST (LIST (LIST :NAME (FIRST VMS-HEADER) :HOST HOST)) :FROM)))
      (VALUES NEWSTAT STOP-BP))))

(DEFUN PARSE-VMS-FROM-HEADER (LINE)
  (LET ((START (STRING-LENGTH "FROM:    ")))
    (LIST (STRING-TRIM " " (SUBSTRING LINE START (+ START 12.)))
          (CONDITION-CASE (ERROR)
              (TIME::PARSE-UNIVERSAL-TIME LINE (+ START 12.)
                                         (STRING-SEARCH-CHAR
                                           #\SP LINE
                                           (1+
                                             (STRING-SEARCH-CHAR #\SP LINE
                                                                 (+ START 12.))))
                                         NIL)
            (ERROR (SEND ERROR :REPORT-STRING))))))

(DEFUN PARSE-VMS-TO-HEADER (LINE HOST &AUX COMMA TEM)
  (DO ((INDEX (STRING-LENGTH "TO:       "))
       (END (LENGTH LINE))
       RCPTS)
      (( INDEX END) RCPTS)
    (SETQ COMMA (STRING-SEARCH-CHAR #\, LINE INDEX))
    (SETQ TEM (STRING-TRIM " " (SUBSTRING LINE INDEX COMMA)))
    (UNLESS (EQUAL TEM "")
      (PUSH (LIST :NAME TEM :HOST HOST) RCPTS))
    (IF COMMA
        (SETQ INDEX (1+ COMMA))
      (RETURN RCPTS))))

(DEFUN PARSE-VMS-SUBJECT-HEADER (LINE)
  (SUBSTRING-AFTER-CHAR #\TAB LINE))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :REFORMAT-MSG-HEADER) (MSG)
  (WITH-BP (SEP (INTERVAL-FIRST-BP (MSG-INTERVAL MSG)) :MOVES)
    (LET ((STRM (INTERVAL-STREAM-INTO-BP (INTERVAL-FIRST-BP (MSG-INTERVAL MSG)))))
      (MULTIPLE-VALUE-BIND (NIL MINUTES HOURS DAY MONTH YEAR)
          (TIME::DECODE-UNIVERSAL-TIME
            (OR (GET (LOCF (MSG-STATUS MSG)) 'RECEIVED-DATE)
                (GET (LOCF (MSG-STATUS MSG)) :DATE)))
        (FORMAT STRM "From:     CHAOSMAIL      ~D-~A-~D ~2,'0D:~2,'0D~%"
                DAY (TIME::MONTH-STRING MONTH :SHORT) (+ 1900. YEAR) HOURS MINUTES))
      (DO ((TAIL (MSG-STATUS MSG) (CDDR TAIL)))
          ((NULL TAIL))
        (WHEN (RASSQ (CAR TAIL) *HEADER-NAME-ALIST*)
          (PRINT-HEADER STRM (CADR TAIL) (CAR TAIL)))))
    (TERPRI STREAM)
    (DELETE-INTERVAL SEP (GET (LOCF (MSG-STATUS MSG)) 'HEADERS-END-BP))))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (OR (MAYBE-OVERRIDDEN-MAIL-PATHNAME SELF)
      (SEND SELF :NEW-PATHNAME
                    :NAME "MAIL"
                    :TYPE "MAI"
                    :VERSION :NEWEST)))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  "ZML")

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :INBOX-BUFFER-FLAVOR) ()
  'VMS-INBOX-BUFFER)

(DEFFLAVOR VMS-INBOX-BUFFER () (VMS-MAIL-FILE-MIXIN INBOX-BUFFER))

(DEFMETHOD (VMS-INBOX-BUFFER :BEFORE :PARSE-MSG) (MSG -STATUS-)
  MSG
  (PUTPROP -STATUS- T 'UNSEEN))
